home
***
CD-ROM
|
disk
|
FTP
|
other
***
search
/
Workbench Add-On
/
Workbench Add-On - Volume 1.iso
/
Dev
/
Oberon
/
source
/
OC
/
OCM.mod
< prev
next >
Wrap
Text File
|
1995-07-02
|
21KB
|
681 lines
(*************************************************************************
$RCSfile: OCM.mod $
Description: Machine-specific declarations and operations.
Created by: fjc (Frank Copeland)
$Revision: 5.18 $
$Author: fjc $
$Date: 1995/06/02 18:30:56 $
Copyright © 1993-1995, Frank Copeland
This module forms part of the OC program
See OC.doc for conditions of use and distribution
Log entries are at the end of the file.
*************************************************************************)
<* STANDARD- *> <* MAIN- *>
MODULE OCM;
IMPORT
SYS := SYSTEM, e := Exec, d := Dos, du := DosUtil,
str := Strings, wb := Workbench, i := Icon;
CONST
(* Sizes in bytes of basic data types. *)
ByteSize * = 1; BoolSize * = 1; CharSize * = 1;
SIntSize * = 1; IntSize * = 2; LIntSize * = 4;
RealSize * = 4; LRealSize * = RealSize;
BSetSize * = 1; WSetSize * = 2; SetSize * = 4;
PtrSize * = 4; ProcSize * = 4;
(* Minima and Maxima of basic data types. *)
MinBool * = 0; MaxBool * = 1; MinChar * = 0; MaxChar * = 0FFH;
MinSInt * = -80H; MaxSInt * = 7FH;
MinInt * = -8000H; MaxInt * = 7FFFH;
MinLInt * = 80000000H; MaxLInt * = 7FFFFFFFH;
MinSet * = 0; MaxBSet * = 7; MaxWSet * = 15; MaxSet * = 31;
(* REALs are implemented as Motorola FFP Single-Precision reals. *)
MinReal * = MIN (REAL); (*-9.22337177E18*)
MaxReal * = MAX (REAL); (*+9.22337177E18*)
MaxExp * = 18;
(*
For now, LONGREALs are the same as REALs. In future, they will be
implemented as IEEE double-precision reals.
*)
MinLReal * = MinReal; MaxLReal * = MaxReal; MaxLExp * = MaxExp;
(*
** Maximum size of a procedure's parameter list. This must correspond
** to the constant used by the stack checking code. See STACKCHK.asm.
** *Must* be at least 1500, to allow for the stack requirements of
** dos.library functions.
*)
ParLimit * = 1500;
(* Maximum size of a module's global variables. Note that this value
** far exceeds the maximum amount of memory installed in any Amiga
** produced so far.
*)
VarLimit * = MAX (LONGINT) - 3;
(* Maximum size of a procedure's local variables. *)
LVarLimit * = MIN (INTEGER);
(* Maximum size of a compound type. *)
MaxTypeSize * = MAX (LONGINT) - 1;
(*
** Maximum number of extensions allowed for record types. This equals
** the number of slots available in the type descriptor.
*)
ExtendLimit * = 15;
(*
* Object and item modes, used by Module OCT and others. These are
* subject to change.
*)
Undef * = 0;
Var * = 1; (* local and global variables and value parameters *)
VarR * = 2; (* value parameter in register *)
VarX * = 3; (* indexed array variables *)
VarArg * = 4; (* C-style vararg pushed on stack *)
Ind * = 5; (* variable parameters *)
IndR * = 6; (* variable parameter in register *)
IndX * = 7; (* indexed dynamic array parameters *)
RegI * = 8; (* register indirect mode with displacement *)
RegX * = 9; (* register indirect mode with displacement and index *)
Lab * = 10; (* absolute mode, the address of a label *)
LabI * = 11; (* immediate mode, the address of a label *)
Abs * = 12; (* absolute mode *)
Con * = 13; (* constants *)
Push * = 14; (* register indirect mode with predecrement *)
Pop * = 15; (* register indirect mode with postincrement *)
Coc * = 16; (* condition code *)
Reg * = 17; (* register direct mode *)
RList * = 18; (* Register list for MOVEM *)
Fld * = 19; (* record fields *)
Typ * = 20; (* types *)
LProc * = 21; (* local (non-exportable) procedures *)
XProc * = 22; (* exportable procedures *)
TProc * = 23; (* Type-bound procedures *)
SProc * = 24; (* standard procedures *)
LibCall * = 25; (* Amiga library functions *)
M2Proc * = 26; (* External procedure (Modula-2 conventions) *)
CProc * = 27; (* External procedure (C conventions) *)
AProc * = 28; (* External procedure (Assembly conventions) *)
CallBack * = 29; (* CallBack procedure (Assembly conventions) *)
Mod * = 30; (* Modules *)
Head * = 31; (* symbol scope header *)
(* System flags, used in the foreign code interface *)
DefaultFlag * = -1; (* Use current default *)
OberonFlag * = 0; (* Use Oberon conventions (default) *)
M2Flag * = 1; (* Use Modula-2 conventions *)
CFlag * = 2; (* Use C conventions *)
BCPLFlag * = 3; (* Use BCPL conventions *)
AsmFlag * = 4; (* Use Assembler conventions *)
CBackFlag * = 5; (* Call-back procedure, with register parameters *)
(* Preferences settings *)
CONST
PathLen* = 256; (* Max length of a path name. *)
ExtLen* = 16; (* Max length of an extension. *)
maxPaths* = 10; (* Max number of search paths. *)
OCPF = 04F435046H; (* "OCPF" *) (* Tag for preferences file. *)
PrefsVersion = 5; (* Preferences file version. *)
(* Icon types *)
iconSym* = 0; iconObj* = 1; iconErr* = 2;
TYPE
Path = ARRAY PathLen OF CHAR;
Extension = ARRAY ExtLen OF CHAR;
VAR
PrefsFile*, (* Name of current prefs file. *)
SymPath*, (* Destination for symbol files. *)
ObjPath*, (* Destination for object files. *)
ErrPath*, (* Destination for error files. *)
SetNames*, (* Selectors to be set. *)
ClearNames* (* Selectors to be cleared. *)
: Path;
SymExt*, (* Extension for symbol files *)
ObjExt*, (* Extension for object files *)
ErrExt* (* Extension for error files *)
: Extension;
Standard*,
Initialise*,
Main*,
Warnings*,
Register*,
Debug*, (* Output symbol hunks *)
SmallCode*,
SmallData*,
Resident*,
TypeChk*,
OvflChk*,
IndexChk*,
RangeChk*,
CaseChk*,
NilChk*, (* Default values for pragmas *)
ReturnChk*,
StackChk*,
LongVars*,
ClearVars*,
AssertChk*,
Verbose*, (* Verbose compiler output. *)
MakeIcons* (* Create icons for symbol, object
** and error files.
*)
: BOOLEAN;
CodeSize*, (* Size of code buffer. *)
ConstSize* (* Size of constants buffer. *)
: LONGINT;
searchPath- (* Array of search paths. *)
: ARRAY maxPaths + 1 OF e.LSTRPTR;
pathx- : INTEGER; (* Current # of search paths. *)
CONST
defSymPath = ""; (* Default symbol file path. *)
defObjPath = ""; (* Default object file path. *)
defErrPath = "T:"; (* Default error file path. *)
defSymExt = ".sym"; (* Default symbol file extension. *)
defObjExt = ".obj"; (* Default object file extension. *)
defErrExt = ".err"; (* Default error file extension. *)
defStandard = TRUE;
defInitialise = TRUE;
defMain = TRUE;
defWarnings = TRUE;
defRegister = FALSE;
defSmallCode = FALSE;
defSmallData = FALSE;
defResident = FALSE;
defTypeChk = TRUE;
defOvflChk = TRUE;
defIndexChk = TRUE;
defRangeChk = TRUE;
defCaseChk = TRUE;
defNilChk = TRUE;
defReturnChk = TRUE;
defStackChk = TRUE;
defLongVars = FALSE;
defClearVars = FALSE;
defAssertChk = TRUE;
defCodeSize = 32000;
defConstSize = 32000;
(* Force generation of symbol and object files *)
VAR
Force* : BOOLEAN;
(*------------------------------------*)
PROCEDURE LoadPrefs* ( fileName : ARRAY OF CHAR ) : BOOLEAN;
VAR
pf : d.FileHandlePtr;
s : ARRAY PathLen OF CHAR;
dir : ARRAY 3 OF e.LSTRPTR;
tag : LONGINT; i, ver : INTEGER;
c : CHAR;
PROCEDURE Read ( fh : d.FileHandlePtr; VAR x : SYS.BYTE );
VAR i : LONGINT;
BEGIN (* Read *)
i := d.FGetC (fh); x := CHR (i)
END Read;
PROCEDURE ReadBytes
( fh : d.FileHandlePtr; VAR x : ARRAY OF SYS.BYTE; n : LONGINT );
VAR i : LONGINT;
BEGIN (* ReadBytes *)
i := d.FRead (fh, x, 1, n)
END ReadBytes;
PROCEDURE ReadString ( fh : d.FileHandlePtr; VAR x : ARRAY OF CHAR );
VAR ch : CHAR; i : INTEGER;
BEGIN (* ReadString *)
i := 0;
REPEAT
Read (fh, ch); x [i] := ch; INC (i)
UNTIL ch = 0X
END ReadString;
PROCEDURE ReadBool ( fh : d.FileHandlePtr; VAR x : BOOLEAN );
VAR i : SHORTINT;
BEGIN (* ReadBool *)
Read (fh, i); x := (i # 0)
END ReadBool;
PROCEDURE ReadInt ( fh : d.FileHandlePtr; VAR i : LONGINT );
VAR res : LONGINT;
BEGIN (* ReadInt *)
res := d.FRead (fh, i, 4, 1)
END ReadInt;
<*$CopyArrays-*>
BEGIN (* LoadPrefs *)
dir [0] := SYS.ADR ("PROGDIR:");
dir [1] := SYS.ADR ("ENV:OC");
dir [2] := NIL;
IF du.Search (dir, fileName, s) THEN
pf := d.Open (s, d.oldFile);
IF pf # NIL THEN
ReadBytes (pf, tag, 4);
IF tag = OCPF THEN
Read (pf, c); ver := ORD (c);
IF ver >= 1 THEN
ReadString (pf, SymPath);
ReadString (pf, ObjPath);
ReadString (pf, ErrPath);
ReadString (pf, SetNames);
ReadString (pf, ClearNames);
ReadString (pf, SymExt);
ReadString (pf, ObjExt);
ReadString (pf, ErrExt);
pathx := 0;
LOOP
ReadString (pf, s);
IF s = "" THEN EXIT END;
SYS.NEW (searchPath [pathx], str.Length (s) + 1);
COPY (s, searchPath [pathx]^); INC (pathx)
END;
searchPath [pathx] := NIL;
ReadBool (pf, Verbose);
ReadBool (pf, MakeIcons);
ReadBool (pf, Debug);
SmallCode := defSmallCode;
SmallData := defSmallData;
Resident := defRegister;
Register := defRegister;
CodeSize := defCodeSize;
ConstSize := defConstSize;
Standard := defStandard;
Initialise := defInitialise;
Main := defMain;
Warnings := defWarnings;
TypeChk := defTypeChk;
OvflChk := defOvflChk;
IndexChk := defIndexChk;
RangeChk := defRangeChk;
CaseChk := defCaseChk;
NilChk := defNilChk;
ReturnChk := defReturnChk;
StackChk := defStackChk;
LongVars := defLongVars;
ClearVars := defClearVars;
AssertChk := defAssertChk;
IF ver >= 2 THEN
ReadBool (pf, SmallCode);
ReadBool (pf, SmallData);
ReadBool (pf, Register);
IF ver >= 3 THEN
ReadInt (pf, CodeSize);
ReadInt (pf, ConstSize);
IF ver >= 4 THEN
ReadBool (pf, Resident);
IF ver >= 5 THEN
ReadBool (pf, Standard);
ReadBool (pf, Initialise);
ReadBool (pf, Main);
ReadBool (pf, Warnings);
ReadBool (pf, TypeChk);
ReadBool (pf, OvflChk);
ReadBool (pf, IndexChk);
ReadBool (pf, RangeChk);
ReadBool (pf, CaseChk);
ReadBool (pf, NilChk);
ReadBool (pf, ReturnChk);
ReadBool (pf, StackChk);
ReadBool (pf, LongVars);
ReadBool (pf, ClearVars);
ReadBool (pf, AssertChk);
END;
END
END
END;
d.OldClose (pf);
COPY (fileName, PrefsFile);
RETURN TRUE
ELSE
d.OldClose (pf);
RETURN FALSE
END;
ELSE
d.OldClose (pf);
RETURN FALSE
END;
ELSE
RETURN FALSE
END;
ELSE
RETURN FALSE
END;
END LoadPrefs;
(*------------------------------------*)
PROCEDURE SavePrefs* ( fileName : ARRAY OF CHAR ) : BOOLEAN;
VAR pf : d.FileHandlePtr; tag : LONGINT; i : INTEGER; ver : CHAR;
PROCEDURE Write ( fh : d.FileHandlePtr; x : SYS.BYTE );
VAR i : LONGINT;
BEGIN (* Write *)
i := d.FPutC (fh, ORD (x))
END Write;
PROCEDURE WriteBytes
( fh : d.FileHandlePtr; VAR x : ARRAY OF SYS.BYTE; n : LONGINT );
VAR i : LONGINT;
BEGIN (* WriteBytes *)
i := d.FWrite (fh, x, 1, n)
END WriteBytes;
PROCEDURE WriteString ( fh : d.FileHandlePtr; x : ARRAY OF CHAR );
<*$CopyArrays-*>
BEGIN (* WriteString *)
WriteBytes (fh, x, str.Length (x)); Write (fh, 0X)
END WriteString;
PROCEDURE WriteBool ( fh : d.FileHandlePtr; x : BOOLEAN );
VAR i : SHORTINT;
BEGIN (* WriteBool *)
IF x THEN i := 1 ELSE i := 0 END; Write (fh, i)
END WriteBool;
PROCEDURE WriteInt ( fh : d.FileHandlePtr; VAR i : LONGINT );
VAR res : LONGINT;
BEGIN (* WriteInt *)
res := d.FWrite (fh, i, 4, 1)
END WriteInt;
<*$CopyArrays-*>
BEGIN (* SavePrefs *)
pf := d.Open (fileName, d.newFile);
IF pf # NIL THEN
tag := OCPF; WriteBytes (pf, tag, 4);
Write (pf, CHR (PrefsVersion));
WriteString (pf, SymPath);
WriteString (pf, ObjPath);
WriteString (pf, ErrPath);
WriteString (pf, SetNames);
WriteString (pf, ClearNames);
WriteString (pf, SymExt);
WriteString (pf, ObjExt);
WriteString (pf, ErrExt);
FOR i := 0 TO pathx - 1 DO WriteString (pf, searchPath [i]^) END;
WriteString (pf, "");
WriteBool (pf, Verbose);
WriteBool (pf, MakeIcons);
WriteBool (pf, Debug);
WriteBool (pf, SmallCode);
WriteBool (pf, SmallData);
WriteBool (pf, Register);
WriteInt (pf, CodeSize);
WriteInt (pf, ConstSize);
WriteBool (pf, Resident);
WriteBool (pf, Standard);
WriteBool (pf, Initialise);
WriteBool (pf, Main);
WriteBool (pf, Warnings);
WriteBool (pf, TypeChk);
WriteBool (pf, OvflChk);
WriteBool (pf, IndexChk);
WriteBool (pf, RangeChk);
WriteBool (pf, CaseChk);
WriteBool (pf, NilChk);
WriteBool (pf, ReturnChk);
WriteBool (pf, StackChk);
WriteBool (pf, LongVars);
WriteBool (pf, ClearVars);
WriteBool (pf, AssertChk);
d.OldClose (pf);
COPY (fileName, PrefsFile);
RETURN TRUE
ELSE
RETURN FALSE
END
END SavePrefs;
(*------------------------------------*)
PROCEDURE ClearSearchPaths*;
BEGIN (* ClearSearchPaths *)
pathx := 0; searchPath [0] := NIL
END ClearSearchPaths;
(*------------------------------------*)
PROCEDURE AddSearchPath * (newPath : e.LSTRPTR);
BEGIN (* AddSearchPath *)
IF pathx >= maxPaths THEN
HALT (922)
ELSE
searchPath [pathx] := newPath; INC (pathx); searchPath [pathx] := NIL
END;
END AddSearchPath;
(*------------------------------------*)
PROCEDURE FindSymbolFile *
( module : ARRAY OF CHAR;
VAR path : ARRAY OF CHAR )
: BOOLEAN;
VAR name : ARRAY 32 OF CHAR;
<*$CopyArrays-*>
BEGIN (* FindSymbolFile *)
COPY (module, name); str.Append (SymExt, name);
RETURN du.Search (searchPath, name, path)
END FindSymbolFile;
(*------------------------------------*)
PROCEDURE MakeFileName
( module, ext : ARRAY OF CHAR;
VAR path : ARRAY OF CHAR );
VAR name : ARRAY 32 OF CHAR;
<*$CopyArrays-*>
BEGIN (* MakeFileName *)
COPY (module, name); str.Append (ext, name);
IF d.AddPart (path, name, LEN (path)) THEN END
END MakeFileName;
(*------------------------------------*)
PROCEDURE SymbolFileName *
( module : ARRAY OF CHAR;
VAR path : ARRAY OF CHAR;
fullPath : BOOLEAN );
<*$CopyArrays-*>
BEGIN (* SymbolFileName *)
IF fullPath THEN
COPY (SymPath, path); MakeFileName (module, SymExt, path)
ELSE
COPY (module, path); str.Append (SymExt, path)
END
END SymbolFileName;
(*------------------------------------*)
PROCEDURE ObjectFileName *
( module : ARRAY OF CHAR;
VAR path : ARRAY OF CHAR );
<*$CopyArrays-*>
BEGIN (* ObjectFileName *)
COPY (ObjPath, path); MakeFileName (module, ObjExt, path)
END ObjectFileName;
(*------------------------------------*)
PROCEDURE ErrorFileName *
( module : ARRAY OF CHAR;
VAR path : ARRAY OF CHAR );
<*$CopyArrays-*>
BEGIN (* ErrorFileName *)
COPY (ErrPath, path); MakeFileName (module, ErrExt, path);
END ErrorFileName;
(*------------------------------------*)
PROCEDURE MakeIcon* ( file : ARRAY OF CHAR; type : INTEGER );
VAR
icon : Path;
diskObj : wb.DiskObjectPtr;
filePart : e.LSTRPTR;
<*$CopyArrays-*>
BEGIN (* MakeIcon *)
IF MakeIcons THEN
ASSERT (i.base # NIL, 100);
COPY (file, icon); str.Append (".info", icon);
IF ~du.FileExists (icon) THEN
CASE type OF
iconSym : icon := "ENV:OC/def_sym" |
iconObj : icon := "ENV:OC/def_obj" |
iconErr : icon := "ENV:OC/def_err" |
END;
diskObj := i.GetDiskObject (icon);
IF diskObj = NIL THEN diskObj := i.GetDefDiskObject (wb.project) END;
IF diskObj # NIL THEN
diskObj.currentX := wb.noIconPosition;
diskObj.currentY := wb.noIconPosition;
IF ~i.PutDiskObject (file, diskObj) THEN
IF d.PrintFault (d.IoErr(), "PutDiskObject") THEN END;
END;
i.FreeDiskObject (diskObj)
ELSE
IF d.PrintFault (d.IoErr(), "GetDiskObject") THEN END;
END
END
END
END MakeIcon;
BEGIN
Verbose := TRUE; MakeIcons := FALSE; Debug := FALSE; Force := FALSE;
SymPath := defSymPath; ObjPath := defObjPath; ErrPath := defErrPath;
SymExt := defSymExt; ObjExt := defObjExt; ErrExt := defErrExt;
SmallCode := defSmallCode; SmallData := defSmallData;
Resident := defResident; Register := defRegister;
CodeSize := defCodeSize; ConstSize := defConstSize;
Standard := defStandard; Initialise := defInitialise;
Main := defMain; Warnings := defWarnings;
TypeChk := defTypeChk; OvflChk := defOvflChk;
IndexChk := defIndexChk; RangeChk := defRangeChk;
CaseChk := defCaseChk; NilChk := defNilChk;
ReturnChk := defReturnChk; StackChk := defStackChk;
LongVars := defLongVars; ClearVars := defClearVars;
AssertChk := defAssertChk;
searchPath [0] := NIL; pathx := 0;
PrefsFile := ""
END OCM.
(***************************************************************************
$Log: OCM.mod $
Revision 5.18 1995/06/02 18:30:56 fjc
- Declared ExtendLimit.
- Added compiler options and pragmas to settings file.
Revision 5.17 1995/05/19 15:58:52 fjc
- Moved console IO to module OCOut.
Revision 5.16 1995/05/13 23:01:00 fjc
- Exported some constants.
Revision 5.15 1995/05/08 17:05:36 fjc
- Now holds the preferences file's name in PrefsFile.
Revision 5.13 1995/04/02 13:33:58 fjc
- Added CODESIZE and CONSTSIZE settings.
Revision 5.12 1995/03/13 11:19:17 fjc
- Added new modes: VarR and IndR.
- Added new flag : CBackProc.
Revision 5.11 1995/02/27 16:45:13 fjc
- Removed tracing code.
- Added SmallCode, SmallData and Register settings, and
changed preferences file format to reflect this.
Revision 5.10 1995/01/26 00:17:17 fjc
- Release 1.5
Revision 5.9 1995/01/16 10:30:02 fjc
- Uses direct calls to AmigaDOS for reading and writing
preferences files.
Revision 5.8 1995/01/09 13:44:53 fjc
- Deleted icon names from preferences file format.
- Added MakeIcon().
- Added checks for the existence of directories when
constructing file names.
Revision 5.7 1995/01/05 11:27:26 fjc
- Added check for Ctrl-C break to console I/O procedures.
Revision 5.6 1995/01/03 21:00:03 fjc
- Renamed from OCG to OCM.
- Added support for preferences settings:
- Added variables to hold current settings.
- Added LoadPrefs() and SavePrefs().
- Added ClearSearchPaths().
- Added console I/O procedures to replace module Out.
- Added support for catalogs using module OCStrings.
Revision 5.5 1994/12/16 16:59:59 fjc
- Added code for constructing file names and searching for
symbol files.
Revision 5.4 1994/09/25 17:30:29 fjc
- Overhauled object modes.
- Added system flag declarations.
Revision 5.3 1994/09/19 23:10:05 fjc
- Re-implemented Amiga library calls
Revision 5.2 1994/09/15 10:10:58 fjc
- Replaced switches with pragmas.
- Uses Kernel instead of SYSTEM.
Revision 5.1 1994/09/03 19:29:08 fjc
- Bumped version number
***************************************************************************)